home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tclCmdMZ.c < prev    next >
C/C++ Source or Header  |  1993-07-16  |  43KB  |  1,703 lines
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * All rights reserved.
  11.  *
  12.  * Permission is hereby granted, without written agreement and without
  13.  * license or royalty fees, to use, copy, modify, and distribute this
  14.  * software and its documentation for any purpose, provided that the
  15.  * above copyright notice and the following two paragraphs appear in
  16.  * all copies of this software.
  17.  * 
  18.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22.  *
  23.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28.  */
  29.  
  30. #ifndef lint
  31. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.34 93/07/16 16:50:50 ouster Exp $ SPRITE (Berkeley)";
  32. #endif
  33.  
  34. #include "tclInt.h"
  35.  
  36. /*
  37.  * Structure used to hold information about variable traces:
  38.  */
  39.  
  40. typedef struct {
  41.     int flags;            /* Operations for which Tcl command is
  42.                  * to be invoked. */
  43.     char *errMsg;        /* Error message returned from Tcl command,
  44.                  * or NULL.  Malloc'ed. */
  45.     int length;            /* Number of non-NULL chars. in command. */
  46.     char command[4];        /* Space for Tcl command to invoke.  Actual
  47.                  * size will be as large as necessary to
  48.                  * hold command.  This field must be the
  49.                  * last in the structure, so that it can
  50.                  * be larger than 4 bytes. */
  51. } TraceVarInfo;
  52.  
  53. /*
  54.  * Forward declarations for procedures defined in this file:
  55.  */
  56.  
  57. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  58.                 Tcl_Interp *interp, char *name1, char *name2,
  59.                 int flags));
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * Tcl_RegexpCmd --
  65.  *
  66.  *    This procedure is invoked to process the "regexp" Tcl command.
  67.  *    See the user documentation for details on what it does.
  68.  *
  69.  * Results:
  70.  *    A standard Tcl result.
  71.  *
  72.  * Side effects:
  73.  *    See the user documentation.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78.     /* ARGSUSED */
  79. int
  80. Tcl_RegexpCmd(dummy, interp, argc, argv)
  81.     ClientData dummy;            /* Not used. */
  82.     Tcl_Interp *interp;            /* Current interpreter. */
  83.     int argc;                /* Number of arguments. */
  84.     char **argv;            /* Argument strings. */
  85. {
  86.     int noCase = 0;
  87.     int indices = 0;
  88.     regexp *regexpPtr;
  89.     char **argPtr, *string;
  90.     int match, i;
  91.  
  92.     if (argc < 3) {
  93.     wrongNumArgs:
  94.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  95.         " ?switches? exp string ?matchVar? ?subMatchVar ",
  96.         "subMatchVar ...?\"", (char *) NULL);
  97.     return TCL_ERROR;
  98.     }
  99.     argPtr = argv+1;
  100.     argc--;
  101.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  102.     if (strcmp(argPtr[0], "-indices") == 0) {
  103.         indices = 1;
  104.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  105.         noCase = 1;
  106.     } else if (strcmp(argPtr[0], "--") == 0) {
  107.         argPtr++;
  108.         argc--;
  109.         break;
  110.     } else {
  111.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  112.             "\": must be -indices, -nocase, or --", (char *) NULL);
  113.         return TCL_ERROR;
  114.     }
  115.     argPtr++;
  116.     argc--;
  117.     }
  118.     if (argc < 2) {
  119.     goto wrongNumArgs;
  120.     }
  121.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  122.     if (regexpPtr == NULL) {
  123.     return TCL_ERROR;
  124.     }
  125.  
  126.     /*
  127.      * Convert the string to lower case, if desired, and perform
  128.      * the match.
  129.      */
  130.  
  131.     if (noCase) {
  132.     register char *dst, *src;
  133.  
  134.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  135.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  136.         if (isupper(*src)) {
  137.         *dst = tolower(*src);
  138.         } else {
  139.         *dst = *src;
  140.         }
  141.     }
  142.     *dst = 0;
  143.     } else {
  144.     string = argPtr[1];
  145.     }
  146.     tclRegexpError = NULL;
  147.     match = regexec(regexpPtr, string, string);
  148.     if (string != argPtr[1]) {
  149.     ckfree(string);
  150.     }
  151.     if (tclRegexpError != NULL) {
  152.     Tcl_AppendResult(interp, "error while matching pattern: ",
  153.         tclRegexpError, (char *) NULL);
  154.     return TCL_ERROR;
  155.     }
  156.     if (!match) {
  157.     interp->result = "0";
  158.     return TCL_OK;
  159.     }
  160.  
  161.     /*
  162.      * If additional variable names have been specified, return
  163.      * index information in those variables.
  164.      */
  165.  
  166.     argc -= 2;
  167.     if (argc > NSUBEXP) {
  168.     interp->result = "too many substring variables";
  169.     return TCL_ERROR;
  170.     }
  171.     for (i = 0; i < argc; i++) {
  172.     char *result, info[50];
  173.  
  174.     if (regexpPtr->startp[i] == NULL) {
  175.         if (indices) {
  176.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  177.         } else {
  178.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  179.         }
  180.     } else {
  181.         if (indices) {
  182.         sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  183.             regexpPtr->endp[i] - string - 1);
  184.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  185.         } else {
  186.         char savedChar, *first, *last;
  187.  
  188.         first = argPtr[1] + (regexpPtr->startp[i] - string);
  189.         last = argPtr[1] + (regexpPtr->endp[i] - string);
  190.         savedChar = *last;
  191.         *last = 0;
  192.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  193.         *last = savedChar;
  194.         }
  195.     }
  196.     if (result == NULL) {
  197.         Tcl_AppendResult(interp, "couldn't set variable \"",
  198.             argPtr[i+2], "\"", (char *) NULL);
  199.         return TCL_ERROR;
  200.     }
  201.     }
  202.     interp->result = "1";
  203.     return TCL_OK;
  204. }
  205.  
  206. /*
  207.  *----------------------------------------------------------------------
  208.  *
  209.  * Tcl_RegsubCmd --
  210.  *
  211.  *    This procedure is invoked to process the "regsub" Tcl command.
  212.  *    See the user documentation for details on what it does.
  213.  *
  214.  * Results:
  215.  *    A standard Tcl result.
  216.  *
  217.  * Side effects:
  218.  *    See the user documentation.
  219.  *
  220.  *----------------------------------------------------------------------
  221.  */
  222.  
  223.     /* ARGSUSED */
  224. int
  225. Tcl_RegsubCmd(dummy, interp, argc, argv)
  226.     ClientData dummy;            /* Not used. */
  227.     Tcl_Interp *interp;            /* Current interpreter. */
  228.     int argc;                /* Number of arguments. */
  229.     char **argv;            /* Argument strings. */
  230. {
  231.     int noCase = 0, all = 0;
  232.     regexp *regexpPtr;
  233.     char *string, *p, *firstChar, *newValue, **argPtr;
  234.     int match, result, flags, anyMatches;
  235.     register char *src, c;
  236.  
  237.     if (argc < 5) {
  238.     wrongNumArgs:
  239.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  240.         " ?switches? exp string subSpec varName\"", (char *) NULL);
  241.     return TCL_ERROR;
  242.     }
  243.     argPtr = argv+1;
  244.     argc--;
  245.     while (argPtr[0][0] == '-') {
  246.     if (strcmp(argPtr[0], "-nocase") == 0) {
  247.         noCase = 1;
  248.     } else if (strcmp(argPtr[0], "-all") == 0) {
  249.         all = 1;
  250.     } else if (strcmp(argPtr[0], "--") == 0) {
  251.         argPtr++;
  252.         argc--;
  253.         break;
  254.     } else {
  255.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  256.             "\": must be -all, -nocase, or --", (char *) NULL);
  257.         return TCL_ERROR;
  258.     }
  259.     argPtr++;
  260.     argc--;
  261.     }
  262.     if (argc != 4) {
  263.     goto wrongNumArgs;
  264.     }
  265.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  266.     if (regexpPtr == NULL) {
  267.     return TCL_ERROR;
  268.     }
  269.  
  270.     /*
  271.      * Convert the string to lower case, if desired.
  272.      */
  273.  
  274.     if (noCase) {
  275.     register char *dst;
  276.  
  277.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  278.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  279.         if (isupper(*src)) {
  280.         *dst = tolower(*src);
  281.         } else {
  282.         *dst = *src;
  283.         }
  284.     }
  285.     *dst = 0;
  286.     } else {
  287.     string = argPtr[1];
  288.     }
  289.  
  290.     /*
  291.      * The following loop is to handle multiple matches within the
  292.      * same source string;  each iteration handles one match and its
  293.      * corresponding substitution.  If "-all" hasn't been specified
  294.      * then the loop body only gets executed once.
  295.      */
  296.  
  297.     flags = 0;
  298.     anyMatches = 0;
  299.     for (p = string; *p != 0; ) {
  300.     tclRegexpError = NULL;
  301.     match = regexec(regexpPtr, p, string);
  302.     if (tclRegexpError != NULL) {
  303.         Tcl_AppendResult(interp, "error while matching pattern: ",
  304.             tclRegexpError, (char *) NULL);
  305.         result = TCL_ERROR;
  306.         goto done;
  307.     }
  308.     if (!match) {
  309.         break;
  310.     }
  311.     anyMatches = 1;
  312.  
  313.     /*
  314.      * Copy the portion of the source string before the match to the
  315.      * result variable.
  316.      */
  317.     
  318.     src = argPtr[1] + (regexpPtr->startp[0] - string);
  319.     c = *src;
  320.     *src = 0;
  321.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  322.         flags);
  323.     *src = c;
  324.     flags = TCL_APPEND_VALUE;
  325.     if (newValue == NULL) {
  326.         cantSet:
  327.         Tcl_AppendResult(interp, "couldn't set variable \"",
  328.             argPtr[3], "\"", (char *) NULL);
  329.         result = TCL_ERROR;
  330.         goto done;
  331.     }
  332.     
  333.     /*
  334.      * Append the subSpec argument to the variable, making appropriate
  335.      * substitutions.  This code is a bit hairy because of the backslash
  336.      * conventions and because the code saves up ranges of characters in
  337.      * subSpec to reduce the number of calls to Tcl_SetVar.
  338.      */
  339.     
  340.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  341.         int index;
  342.     
  343.         if (c == '&') {
  344.         index = 0;
  345.         } else if (c == '\\') {
  346.         c = src[1];
  347.         if ((c >= '0') && (c <= '9')) {
  348.             index = c - '0';
  349.         } else if ((c == '\\') || (c == '&')) {
  350.             *src = c;
  351.             src[1] = 0;
  352.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  353.                 TCL_APPEND_VALUE);
  354.             *src = '\\';
  355.             src[1] = c;
  356.             if (newValue == NULL) {
  357.             goto cantSet;
  358.             }
  359.             firstChar = src+2;
  360.             src++;
  361.             continue;
  362.         } else {
  363.             continue;
  364.         }
  365.         } else {
  366.         continue;
  367.         }
  368.         if (firstChar != src) {
  369.         c = *src;
  370.         *src = 0;
  371.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  372.             TCL_APPEND_VALUE);
  373.         *src = c;
  374.         if (newValue == NULL) {
  375.             goto cantSet;
  376.         }
  377.         }
  378.         if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  379.             && (regexpPtr->endp[index] != NULL)) {
  380.         char *first, *last, saved;
  381.     
  382.         first = argPtr[1] + (regexpPtr->startp[index] - string);
  383.         last = argPtr[1] + (regexpPtr->endp[index] - string);
  384.         saved = *last;
  385.         *last = 0;
  386.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  387.             TCL_APPEND_VALUE);
  388.         *last = saved;
  389.         if (newValue == NULL) {
  390.             goto cantSet;
  391.         }
  392.         }
  393.         if (*src == '\\') {
  394.         src++;
  395.         }
  396.         firstChar = src+1;
  397.     }
  398.     if (firstChar != src) {
  399.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  400.             TCL_APPEND_VALUE) == NULL) {
  401.         goto cantSet;
  402.         }
  403.     }
  404.     if (regexpPtr->endp[0] == p) {
  405.         char tmp[2];
  406.  
  407.         /*
  408.          * Always consume at least one character of the input string
  409.          * in order to prevent infinite loops.
  410.          */
  411.  
  412.         tmp[0] = argPtr[1][p - string];
  413.         tmp[1] = 0;
  414.         newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags);
  415.         if (newValue == NULL) {
  416.         goto cantSet;
  417.         }
  418.         p = regexpPtr->endp[0] + 1;
  419.     } else {
  420.         p = regexpPtr->endp[0];
  421.     }
  422.     if (!all) {
  423.         break;
  424.     }
  425.     }
  426.  
  427.     /*
  428.      * Copy the portion of the source string after the last match to the
  429.      * result variable.
  430.      */
  431.  
  432.     if (*p != 0) {
  433.     if (Tcl_SetVar(interp, argPtr[3], p, flags) == NULL) {
  434.         goto cantSet;
  435.     }
  436.     }
  437.     if (anyMatches) {
  438.     interp->result = "1";
  439.     } else {
  440.     interp->result = "0";
  441.     }
  442.     result = TCL_OK;
  443.  
  444.     done:
  445.     if (string != argPtr[1]) {
  446.     ckfree(string);
  447.     }
  448.     return result;
  449. }
  450.  
  451. /*
  452.  *----------------------------------------------------------------------
  453.  *
  454.  * Tcl_RenameCmd --
  455.  *
  456.  *    This procedure is invoked to process the "rename" Tcl command.
  457.  *    See the user documentation for details on what it does.
  458.  *
  459.  * Results:
  460.  *    A standard Tcl result.
  461.  *
  462.  * Side effects:
  463.  *    See the user documentation.
  464.  *
  465.  *----------------------------------------------------------------------
  466.  */
  467.  
  468.     /* ARGSUSED */
  469. int
  470. Tcl_RenameCmd(dummy, interp, argc, argv)
  471.     ClientData dummy;            /* Not used. */
  472.     Tcl_Interp *interp;            /* Current interpreter. */
  473.     int argc;                /* Number of arguments. */
  474.     char **argv;            /* Argument strings. */
  475. {
  476.     register Command *cmdPtr;
  477.     Interp *iPtr = (Interp *) interp;
  478.     Tcl_HashEntry *hPtr;
  479.     int new;
  480.  
  481.     if (argc != 3) {
  482.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  483.         " oldName newName\"", (char *) NULL);
  484.     return TCL_ERROR;
  485.     }
  486.     if (argv[2][0] == '\0') {
  487.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  488.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  489.             "\": command doesn't exist", (char *) NULL);
  490.         return TCL_ERROR;
  491.     }
  492.     return TCL_OK;
  493.     }
  494.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  495.     if (hPtr != NULL) {
  496.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  497.         "\": command already exists", (char *) NULL);
  498.     return TCL_ERROR;
  499.     }
  500.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  501.     if (hPtr == NULL) {
  502.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  503.         "\":  command doesn't exist", (char *) NULL);
  504.     return TCL_ERROR;
  505.     }
  506.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  507.     Tcl_DeleteHashEntry(hPtr);
  508.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  509.     Tcl_SetHashValue(hPtr, cmdPtr);
  510.     return TCL_OK;
  511. }
  512.  
  513. /*
  514.  *----------------------------------------------------------------------
  515.  *
  516.  * Tcl_ReturnCmd --
  517.  *
  518.  *    This procedure is invoked to process the "return" Tcl command.
  519.  *    See the user documentation for details on what it does.
  520.  *
  521.  * Results:
  522.  *    A standard Tcl result.
  523.  *
  524.  * Side effects:
  525.  *    See the user documentation.
  526.  *
  527.  *----------------------------------------------------------------------
  528.  */
  529.  
  530.     /* ARGSUSED */
  531. int
  532. Tcl_ReturnCmd(dummy, interp, argc, argv)
  533.     ClientData dummy;            /* Not used. */
  534.     Tcl_Interp *interp;            /* Current interpreter. */
  535.     int argc;                /* Number of arguments. */
  536.     char **argv;            /* Argument strings. */
  537. {
  538.     Interp *iPtr = (Interp *) interp;
  539.     int c, code;
  540.  
  541.     if (argc > 4) {
  542.     syntaxError:
  543.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  544.         " ?-code code? ?string?\"", (char *) NULL);
  545.     return TCL_ERROR;
  546.     }
  547.     code = TCL_OK;
  548.     if (argc >= 3) {
  549.     if (strcmp(argv[1], "-code") != 0) {
  550.         goto syntaxError;
  551.     }
  552.     c = argv[2][0];
  553.     if ((c == 'o') && (strcmp(argv[2], "ok") == 0)) {
  554.         code = TCL_OK;
  555.     } else if ((c == 'e') && (strcmp(argv[2], "error") == 0)) {
  556.         code = TCL_ERROR;
  557.     } else if ((c == 'r') && (strcmp(argv[2], "return") == 0)) {
  558.         code = TCL_RETURN;
  559.     } else if ((c == 'b') && (strcmp(argv[2], "break") == 0)) {
  560.         code = TCL_BREAK;
  561.     } else if ((c == 'c') && (strcmp(argv[2], "continue") == 0)) {
  562.         code = TCL_CONTINUE;
  563.     } else if (Tcl_GetInt(interp, argv[2], &code) != TCL_OK) {
  564.         Tcl_ResetResult(interp);
  565.         Tcl_AppendResult(interp, "bad completion code \"",
  566.             argv[2], "\": must be ok, error, return, break, ",
  567.             "continue, or an integer", (char *) NULL);
  568.         return TCL_ERROR;
  569.     }
  570.     if (argc == 4) {
  571.         Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
  572.     }
  573.     } else if (argc == 2) {
  574.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  575.     }
  576.     iPtr->returnCode = code;
  577.     return TCL_RETURN;
  578. }
  579.  
  580. /*
  581.  *----------------------------------------------------------------------
  582.  *
  583.  * Tcl_ScanCmd --
  584.  *
  585.  *    This procedure is invoked to process the "scan" Tcl command.
  586.  *    See the user documentation for details on what it does.
  587.  *
  588.  * Results:
  589.  *    A standard Tcl result.
  590.  *
  591.  * Side effects:
  592.  *    See the user documentation.
  593.  *
  594.  *----------------------------------------------------------------------
  595.  */
  596.  
  597.     /* ARGSUSED */
  598. int
  599. Tcl_ScanCmd(dummy, interp, argc, argv)
  600.     ClientData dummy;            /* Not used. */
  601.     Tcl_Interp *interp;            /* Current interpreter. */
  602.     int argc;                /* Number of arguments. */
  603.     char **argv;            /* Argument strings. */
  604. {
  605.     int arg1Length;            /* Number of bytes in argument to be
  606.                      * scanned.  This gives an upper limit
  607.                      * on string field sizes. */
  608. #   define MAX_FIELDS 20
  609.     typedef struct {
  610.     char fmt;            /* Format for field. */
  611.     int size;            /* How many bytes to allow for
  612.                      * field. */
  613.     char *location;            /* Where field will be stored. */
  614.     } Field;
  615.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  616.                      * format string. */
  617.     register Field *curField;
  618.     int numFields = 0;            /* Number of fields actually
  619.                      * specified. */
  620.     int suppress;            /* Current field is assignment-
  621.                      * suppressed. */
  622.     int totalSize = 0;            /* Number of bytes needed to store
  623.                      * all results combined. */
  624.     char *results;            /* Where scanned output goes.
  625.                      * Malloced; NULL means not allocated
  626.                      * yet. */
  627.     int numScanned;            /* sscanf's result. */
  628.     register char *fmt;
  629.     int i, widthSpecified, length, code;
  630.  
  631.     /*
  632.      * The variables below are used to hold a copy of the format
  633.      * string, so that we can replace format specifiers like "%f"
  634.      * and "%F" with specifiers like "%lf"
  635.      */
  636.  
  637. #   define STATIC_SIZE 5
  638.     char copyBuf[STATIC_SIZE], *fmtCopy;
  639.     register char *dst;
  640.  
  641.     if (argc < 3) {
  642.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  643.         " string format ?varName varName ...?\"", (char *) NULL);
  644.     return TCL_ERROR;
  645.     }
  646.  
  647.     /*
  648.      * This procedure operates in four stages:
  649.      * 1. Scan the format string, collecting information about each field.
  650.      * 2. Allocate an array to hold all of the scanned fields.
  651.      * 3. Call sscanf to do all the dirty work, and have it store the
  652.      *    parsed fields in the array.
  653.      * 4. Pick off the fields from the array and assign them to variables.
  654.      */
  655.  
  656.     code = TCL_OK;
  657.     results = NULL;
  658.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  659.     length = strlen(argv[2]) * 2 + 1;
  660.     if (length < STATIC_SIZE) {
  661.     fmtCopy = copyBuf;
  662.     } else {
  663.     fmtCopy = ckalloc((unsigned) length);
  664.     }
  665.     dst = fmtCopy;
  666.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  667.     *dst = *fmt;
  668.     dst++;
  669.     if (*fmt != '%') {
  670.         continue;
  671.     }
  672.     fmt++;
  673.     if (*fmt == '%') {
  674.         *dst = *fmt;
  675.         dst++;
  676.         continue;
  677.     }
  678.     if (*fmt == '*') {
  679.         suppress = 1;
  680.         *dst = *fmt;
  681.         dst++;
  682.         fmt++;
  683.     } else {
  684.         suppress = 0;
  685.     }
  686.     widthSpecified = 0;
  687.     while (isdigit(*fmt)) {
  688.         widthSpecified = 1;
  689.         *dst = *fmt;
  690.         dst++;
  691.         fmt++;
  692.     }
  693.     if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
  694.         fmt++;
  695.     }
  696.     *dst = *fmt;
  697.     dst++;
  698.     if (suppress) {
  699.         continue;
  700.     }
  701.     if (numFields == MAX_FIELDS) {
  702.         interp->result = "too many fields to scan";
  703.         code = TCL_ERROR;
  704.         goto done;
  705.     }
  706.     curField = &fields[numFields];
  707.     numFields++;
  708.     switch (*fmt) {
  709.         case 'd':
  710.         case 'i':
  711.         case 'o':
  712.         case 'x':
  713.         curField->fmt = 'd';
  714.         curField->size = sizeof(int);
  715.         break;
  716.  
  717.         case 'u':
  718.         curField->fmt = 'u';
  719.         curField->size = sizeof(int);
  720.         break;
  721.  
  722.         case 's':
  723.         curField->fmt = 's';
  724.         curField->size = arg1Length;
  725.         break;
  726.  
  727.         case 'c':
  728.                 if (widthSpecified) {
  729.                     interp->result = 
  730.                          "field width may not be specified in %c conversion";
  731.             code = TCL_ERROR;
  732.             goto done;
  733.                 }
  734.         curField->fmt = 'c';
  735.         curField->size = sizeof(int);
  736.         break;
  737.  
  738.         case 'e':
  739.         case 'f':
  740.         case 'g':
  741.         dst[-1] = 'l';
  742.         dst[0] = 'f';
  743.         dst++;
  744.         curField->fmt = 'f';
  745.         curField->size = sizeof(double);
  746.         break;
  747.  
  748.         case '[':
  749.         curField->fmt = 's';
  750.         curField->size = arg1Length;
  751.         do {
  752.             fmt++;
  753.             *dst = *fmt;
  754.             dst++;
  755.         } while (*fmt != ']');
  756.         break;
  757.  
  758.         default:
  759.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  760.             *fmt);
  761.         code = TCL_ERROR;
  762.         goto done;
  763.     }
  764.     totalSize += curField->size;
  765.     }
  766.     *dst = 0;
  767.  
  768.     if (numFields != (argc-3)) {
  769.     interp->result =
  770.         "different numbers of variable names and field specifiers";
  771.     code = TCL_ERROR;
  772.     goto done;
  773.     }
  774.  
  775.     /*
  776.      * Step 2:
  777.      */
  778.  
  779.     results = (char *) ckalloc((unsigned) totalSize);
  780.     for (i = 0, totalSize = 0, curField = fields;
  781.         i < numFields; i++, curField++) {
  782.     curField->location = results + totalSize;
  783.     totalSize += curField->size;
  784.     }
  785.  
  786.     /*
  787.      * Fill in the remaining fields with NULL;  the only purpose of
  788.      * this is to keep some memory analyzers, like Purify, from
  789.      * complaining.
  790.      */
  791.  
  792.     for ( ; i < MAX_FIELDS; i++, curField++) {
  793.     curField->location = NULL;
  794.     }
  795.  
  796.     /*
  797.      * Step 3:
  798.      */
  799.  
  800.     numScanned = sscanf(argv[1], fmtCopy,
  801.         fields[0].location, fields[1].location, fields[2].location,
  802.         fields[3].location, fields[4].location, fields[5].location,
  803.         fields[6].location, fields[7].location, fields[8].location,
  804.         fields[9].location, fields[10].location, fields[11].location,
  805.         fields[12].location, fields[13].location, fields[14].location,
  806.         fields[15].location, fields[16].location, fields[17].location,
  807.         fields[18].location, fields[19].location);
  808.  
  809.     /*
  810.      * Step 4:
  811.      */
  812.  
  813.     if (numScanned < numFields) {
  814.     numFields = numScanned;
  815.     }
  816.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  817.     switch (curField->fmt) {
  818.         char string[TCL_DOUBLE_SPACE];
  819.  
  820.         case 'd':
  821.         sprintf(string, "%d", *((int *) curField->location));
  822.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  823.             storeError:
  824.             Tcl_AppendResult(interp,
  825.                 "couldn't set variable \"", argv[i+3], "\"",
  826.                 (char *) NULL);
  827.             code = TCL_ERROR;
  828.             goto done;
  829.         }
  830.         break;
  831.  
  832.         case 'u':
  833.         sprintf(string, "%u", *((int *) curField->location));
  834.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  835.             goto storeError;
  836.         }
  837.         break;
  838.  
  839.         case 'c':
  840.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  841.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  842.             goto storeError;
  843.         }
  844.         break;
  845.  
  846.         case 's':
  847.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  848.             == NULL) {
  849.             goto storeError;
  850.         }
  851.         break;
  852.  
  853.         case 'f':
  854.         Tcl_PrintDouble(interp, *((double *) curField->location),
  855.             string);
  856.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  857.             goto storeError;
  858.         }
  859.         break;
  860.     }
  861.     }
  862.     sprintf(interp->result, "%d", numScanned);
  863.     done:
  864.     if (results != NULL) {
  865.     ckfree(results);
  866.     }
  867.     if (fmtCopy != copyBuf) {
  868.     ckfree(fmtCopy);
  869.     }
  870.     return code;
  871. }
  872.  
  873. /*
  874.  *----------------------------------------------------------------------
  875.  *
  876.  * Tcl_SplitCmd --
  877.  *
  878.  *    This procedure is invoked to process the "split" Tcl command.
  879.  *    See the user documentation for details on what it does.
  880.  *
  881.  * Results:
  882.  *    A standard Tcl result.
  883.  *
  884.  * Side effects:
  885.  *    See the user documentation.
  886.  *
  887.  *----------------------------------------------------------------------
  888.  */
  889.  
  890.     /* ARGSUSED */
  891. int
  892. Tcl_SplitCmd(dummy, interp, argc, argv)
  893.     ClientData dummy;            /* Not used. */
  894.     Tcl_Interp *interp;            /* Current interpreter. */
  895.     int argc;                /* Number of arguments. */
  896.     char **argv;            /* Argument strings. */
  897. {
  898.     char *splitChars;
  899.     register char *p, *p2;
  900.     char *elementStart;
  901.  
  902.     if (argc == 2) {
  903.     splitChars = " \n\t\r";
  904.     } else if (argc == 3) {
  905.     splitChars = argv[2];
  906.     } else {
  907.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  908.         " string ?splitChars?\"", (char *) NULL);
  909.     return TCL_ERROR;
  910.     }
  911.  
  912.     /*
  913.      * Handle the special case of splitting on every character.
  914.      */
  915.  
  916.     if (*splitChars == 0) {
  917.     char string[2];
  918.     string[1] = 0;
  919.     for (p = argv[1]; *p != 0; p++) {
  920.         string[0] = *p;
  921.         Tcl_AppendElement(interp, string);
  922.     }
  923.     return TCL_OK;
  924.     }
  925.  
  926.     /*
  927.      * Normal case: split on any of a given set of characters.
  928.      * Discard instances of the split characters.
  929.      */
  930.  
  931.     for (p = elementStart = argv[1]; *p != 0; p++) {
  932.     char c = *p;
  933.     for (p2 = splitChars; *p2 != 0; p2++) {
  934.         if (*p2 == c) {
  935.         *p = 0;
  936.         Tcl_AppendElement(interp, elementStart);
  937.         *p = c;
  938.         elementStart = p+1;
  939.         break;
  940.         }
  941.     }
  942.     }
  943.     if (p != argv[1]) {
  944.     Tcl_AppendElement(interp, elementStart);
  945.     }
  946.     return TCL_OK;
  947. }
  948.  
  949. /*
  950.  *----------------------------------------------------------------------
  951.  *
  952.  * Tcl_StringCmd --
  953.  *
  954.  *    This procedure is invoked to process the "string" Tcl command.
  955.  *    See the user documentation for details on what it does.
  956.  *
  957.  * Results:
  958.  *    A standard Tcl result.
  959.  *
  960.  * Side effects:
  961.  *    See the user documentation.
  962.  *
  963.  *----------------------------------------------------------------------
  964.  */
  965.  
  966.     /* ARGSUSED */
  967. int
  968. Tcl_StringCmd(dummy, interp, argc, argv)
  969.     ClientData dummy;            /* Not used. */
  970.     Tcl_Interp *interp;            /* Current interpreter. */
  971.     int argc;                /* Number of arguments. */
  972.     char **argv;            /* Argument strings. */
  973. {
  974.     int length;
  975.     register char *p, c;
  976.     int match;
  977.     int first;
  978.     int left = 0, right = 0;
  979.  
  980.     if (argc < 2) {
  981.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  982.         " option arg ?arg ...?\"", (char *) NULL);
  983.     return TCL_ERROR;
  984.     }
  985.     c = argv[1][0];
  986.     length = strlen(argv[1]);
  987.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  988.     if (argc != 4) {
  989.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  990.             " compare string1 string2\"", (char *) NULL);
  991.         return TCL_ERROR;
  992.     }
  993.     match = strcmp(argv[2], argv[3]);
  994.     if (match > 0) {
  995.         interp->result = "1";
  996.     } else if (match < 0) {
  997.         interp->result = "-1";
  998.     } else {
  999.         interp->result = "0";
  1000.     }
  1001.     return TCL_OK;
  1002.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  1003.     if (argc != 4) {
  1004.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1005.             " first string1 string2\"", (char *) NULL);
  1006.         return TCL_ERROR;
  1007.     }
  1008.     first = 1;
  1009.  
  1010.     firstLast:
  1011.     match = -1;
  1012.     c = *argv[2];
  1013.     length = strlen(argv[2]);
  1014.     for (p = argv[3]; *p != 0; p++) {
  1015.         if (*p != c) {
  1016.         continue;
  1017.         }
  1018.         if (strncmp(argv[2], p, length) == 0) {
  1019.         match = p-argv[3];
  1020.         if (first) {
  1021.             break;
  1022.         }
  1023.         }
  1024.     }
  1025.     sprintf(interp->result, "%d", match);
  1026.     return TCL_OK;
  1027.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  1028.     int index;
  1029.  
  1030.     if (argc != 4) {
  1031.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1032.             " index string charIndex\"", (char *) NULL);
  1033.         return TCL_ERROR;
  1034.     }
  1035.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  1036.         return TCL_ERROR;
  1037.     }
  1038.     if ((index >= 0) && (index < strlen(argv[2]))) {
  1039.         interp->result[0] = argv[2][index];
  1040.         interp->result[1] = 0;
  1041.     }
  1042.     return TCL_OK;
  1043.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  1044.         && (length >= 2)) {
  1045.     if (argc != 4) {
  1046.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1047.             " last string1 string2\"", (char *) NULL);
  1048.         return TCL_ERROR;
  1049.     }
  1050.     first = 0;
  1051.     goto firstLast;
  1052.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  1053.         && (length >= 2)) {
  1054.     if (argc != 3) {
  1055.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1056.             " length string\"", (char *) NULL);
  1057.         return TCL_ERROR;
  1058.     }
  1059.     sprintf(interp->result, "%d", strlen(argv[2]));
  1060.     return TCL_OK;
  1061.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  1062.     if (argc != 4) {
  1063.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1064.             " match pattern string\"", (char *) NULL);
  1065.         return TCL_ERROR;
  1066.     }
  1067.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  1068.         interp->result = "1";
  1069.     } else {
  1070.         interp->result = "0";
  1071.     }
  1072.     return TCL_OK;
  1073.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  1074.     int first, last, stringLength;
  1075.  
  1076.     if (argc != 5) {
  1077.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1078.             " range string first last\"", (char *) NULL);
  1079.         return TCL_ERROR;
  1080.     }
  1081.     stringLength = strlen(argv[2]);
  1082.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  1083.         return TCL_ERROR;
  1084.     }
  1085.     if ((*argv[4] == 'e')
  1086.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  1087.         last = stringLength-1;
  1088.     } else {
  1089.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  1090.         Tcl_ResetResult(interp);
  1091.         Tcl_AppendResult(interp,
  1092.             "expected integer or \"end\" but got \"",
  1093.             argv[4], "\"", (char *) NULL);
  1094.         return TCL_ERROR;
  1095.         }
  1096.     }
  1097.     if (first < 0) {
  1098.         first = 0;
  1099.     }
  1100.     if (last >= stringLength) {
  1101.         last = stringLength-1;
  1102.     }
  1103.     if (last >= first) {
  1104.         char saved, *p;
  1105.  
  1106.         p = argv[2] + last + 1;
  1107.         saved = *p;
  1108.         *p = 0;
  1109.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  1110.         *p = saved;
  1111.     }
  1112.     return TCL_OK;
  1113.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  1114.         && (length >= 3)) {
  1115.     register char *p;
  1116.  
  1117.     if (argc != 3) {
  1118.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1119.             " tolower string\"", (char *) NULL);
  1120.         return TCL_ERROR;
  1121.     }
  1122.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1123.     for (p = interp->result; *p != 0; p++) {
  1124.         if (isupper(*p)) {
  1125.         *p = tolower(*p);
  1126.         }
  1127.     }
  1128.     return TCL_OK;
  1129.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1130.         && (length >= 3)) {
  1131.     register char *p;
  1132.  
  1133.     if (argc != 3) {
  1134.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1135.             " toupper string\"", (char *) NULL);
  1136.         return TCL_ERROR;
  1137.     }
  1138.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1139.     for (p = interp->result; *p != 0; p++) {
  1140.         if (islower(*p)) {
  1141.         *p = toupper(*p);
  1142.         }
  1143.     }
  1144.     return TCL_OK;
  1145.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1146.         && (length == 4)) {
  1147.     char *trimChars;
  1148.     register char *p, *checkPtr;
  1149.  
  1150.     left = right = 1;
  1151.  
  1152.     trim:
  1153.     if (argc == 4) {
  1154.         trimChars = argv[3];
  1155.     } else if (argc == 3) {
  1156.         trimChars = " \t\n\r";
  1157.     } else {
  1158.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1159.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1160.         return TCL_ERROR;
  1161.     }
  1162.     p = argv[2];
  1163.     if (left) {
  1164.         for (c = *p; c != 0; p++, c = *p) {
  1165.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1166.             if (*checkPtr == 0) {
  1167.             goto doneLeft;
  1168.             }
  1169.         }
  1170.         }
  1171.     }
  1172.     doneLeft:
  1173.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1174.     if (right) {
  1175.         char *donePtr;
  1176.  
  1177.         p = interp->result + strlen(interp->result) - 1;
  1178.         donePtr = &interp->result[-1];
  1179.         for (c = *p; p != donePtr; p--, c = *p) {
  1180.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1181.             if (*checkPtr == 0) {
  1182.             goto doneRight;
  1183.             }
  1184.         }
  1185.         }
  1186.         doneRight:
  1187.         p[1] = 0;
  1188.     }
  1189.     return TCL_OK;
  1190.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1191.         && (length > 4)) {
  1192.     left = 1;
  1193.     argv[1] = "trimleft";
  1194.     goto trim;
  1195.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1196.         && (length > 4)) {
  1197.     right = 1;
  1198.     argv[1] = "trimright";
  1199.     goto trim;
  1200.     } else {
  1201.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1202.         "\": should be compare, first, index, last, length, match, ",
  1203.         "range, tolower, toupper, trim, trimleft, or trimright",
  1204.         (char *) NULL);
  1205.     return TCL_ERROR;
  1206.     }
  1207. }
  1208.  
  1209. /*
  1210.  *----------------------------------------------------------------------
  1211.  *
  1212.  * Tcl_SwitchCmd --
  1213.  *
  1214.  *    This procedure is invoked to process the "switch" Tcl command.
  1215.  *    See the user documentation for details on what it does.
  1216.  *
  1217.  * Results:
  1218.  *    A standard Tcl result.
  1219.  *
  1220.  * Side effects:
  1221.  *    See the user documentation.
  1222.  *
  1223.  *----------------------------------------------------------------------
  1224.  */
  1225.  
  1226.     /* ARGSUSED */
  1227. int
  1228. Tcl_SwitchCmd(dummy, interp, argc, argv)
  1229.     ClientData dummy;            /* Not used. */
  1230.     Tcl_Interp *interp;            /* Current interpreter. */
  1231.     int argc;                /* Number of arguments. */
  1232.     char **argv;            /* Argument strings. */
  1233. {
  1234. #define EXACT    0
  1235. #define GLOB    1
  1236. #define REGEXP    2
  1237.     int i, code, mode, matched;
  1238.     int body;
  1239.     char *string;
  1240.     int switchArgc, splitArgs;
  1241.     char **switchArgv;
  1242.  
  1243.     switchArgc = argc-1;
  1244.     switchArgv = argv+1;
  1245.     mode = EXACT;
  1246.     while ((switchArgc > 0) && (*switchArgv[0] == '-')) {
  1247.     if (strcmp(*switchArgv, "-exact") == 0) {
  1248.         mode = EXACT;
  1249.     } else if (strcmp(*switchArgv, "-glob") == 0) {
  1250.         mode = GLOB;
  1251.     } else if (strcmp(*switchArgv, "-regexp") == 0) {
  1252.         mode = REGEXP;
  1253.     } else if (strcmp(*switchArgv, "--") == 0) {
  1254.         switchArgc--;
  1255.         switchArgv++;
  1256.         break;
  1257.     } else {
  1258.         Tcl_AppendResult(interp, "bad option \"", switchArgv[0],
  1259.             "\": should be -exact, -glob, -regexp, or --",
  1260.             (char *) NULL);
  1261.         return TCL_ERROR;
  1262.     }
  1263.     switchArgc--;
  1264.     switchArgv++;
  1265.     }
  1266.     if (switchArgc < 2) {
  1267.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1268.         argv[0], " ?switches? string pattern body ... ?default body?\"",
  1269.         (char *) NULL);
  1270.     return TCL_ERROR;
  1271.     }
  1272.     string = *switchArgv;
  1273.     switchArgc--;
  1274.     switchArgv++;
  1275.  
  1276.     /*
  1277.      * If all of the pattern/command pairs are lumped into a single
  1278.      * argument, split them out again.
  1279.      */
  1280.  
  1281.     splitArgs = 0;
  1282.     if (switchArgc == 1) {
  1283.     code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv);
  1284.     if (code != TCL_OK) {
  1285.         return code;
  1286.     }
  1287.     splitArgs = 1;
  1288.     }
  1289.  
  1290.     body = -1;
  1291.     for (i = 0; i < switchArgc; i += 2) {
  1292.     if (i == (switchArgc-1)) {
  1293.         interp->result = "extra switch pattern with no body";
  1294.         code = TCL_ERROR;
  1295.         goto cleanup;
  1296.     }
  1297.  
  1298.     /*
  1299.      * See if the pattern matches the string.
  1300.      */
  1301.  
  1302.     matched = 0;
  1303.     if ((*switchArgv[i] == 'd') && (i == switchArgc-2)
  1304.         && (strcmp(switchArgv[i], "default") == 0)) {
  1305.         matched = 1;
  1306.     } else {
  1307.         switch (mode) {
  1308.         case EXACT:
  1309.             matched = (strcmp(string, switchArgv[i]) == 0);
  1310.             break;
  1311.         case GLOB:
  1312.             matched = Tcl_StringMatch(string, switchArgv[i]);
  1313.             break;
  1314.         case REGEXP:
  1315.             matched = Tcl_RegExpMatch(interp, string, switchArgv[i]);
  1316.             if (matched < 0) {
  1317.             code = TCL_ERROR;
  1318.             goto cleanup;
  1319.             }
  1320.             break;
  1321.         }
  1322.     }
  1323.     if (!matched) {
  1324.         continue;
  1325.     }
  1326.  
  1327.     /*
  1328.      * We've got a match.  Find a body to execute, skipping bodies
  1329.      * that are "-".
  1330.      */
  1331.  
  1332.     for (body = i+1; ; body += 2) {
  1333.         if (body >= switchArgc) {
  1334.         Tcl_AppendResult(interp, "no body specified for pattern \"",
  1335.             switchArgv[i], "\"", (char *) NULL);
  1336.         code = TCL_ERROR;
  1337.         goto cleanup;
  1338.         }
  1339.         if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) {
  1340.         break;
  1341.         }
  1342.     }
  1343.     code = Tcl_Eval(interp, switchArgv[body]);
  1344.     if (code == TCL_ERROR) {
  1345.         char msg[100];
  1346.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", switchArgv[i],
  1347.             interp->errorLine);
  1348.         Tcl_AddErrorInfo(interp, msg);
  1349.     }
  1350.     goto cleanup;
  1351.     }
  1352.  
  1353.     /*
  1354.      * Nothing matched:  return nothing.
  1355.      */
  1356.  
  1357.     code = TCL_OK;
  1358.  
  1359.     cleanup:
  1360.     if (splitArgs) {
  1361.     ckfree((char *) switchArgv);
  1362.     }
  1363.     return code;
  1364. }
  1365.  
  1366. /*
  1367.  *----------------------------------------------------------------------
  1368.  *
  1369.  * Tcl_TraceCmd --
  1370.  *
  1371.  *    This procedure is invoked to process the "trace" Tcl command.
  1372.  *    See the user documentation for details on what it does.
  1373.  *
  1374.  * Results:
  1375.  *    A standard Tcl result.
  1376.  *
  1377.  * Side effects:
  1378.  *    See the user documentation.
  1379.  *
  1380.  *----------------------------------------------------------------------
  1381.  */
  1382.  
  1383.     /* ARGSUSED */
  1384. int
  1385. Tcl_TraceCmd(dummy, interp, argc, argv)
  1386.     ClientData dummy;            /* Not used. */
  1387.     Tcl_Interp *interp;            /* Current interpreter. */
  1388.     int argc;                /* Number of arguments. */
  1389.     char **argv;            /* Argument strings. */
  1390. {
  1391.     char c;
  1392.     int length;
  1393.  
  1394.     if (argc < 2) {
  1395.     Tcl_AppendResult(interp, "too few args: should be \"",
  1396.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1397.     return TCL_ERROR;
  1398.     }
  1399.     c = argv[1][1];
  1400.     length = strlen(argv[1]);
  1401.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1402.         && (length >= 2)) {
  1403.     char *p;
  1404.     int flags, length;
  1405.     TraceVarInfo *tvarPtr;
  1406.  
  1407.     if (argc != 5) {
  1408.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1409.             argv[0], " variable name ops command\"", (char *) NULL);
  1410.         return TCL_ERROR;
  1411.     }
  1412.  
  1413.     flags = 0;
  1414.     for (p = argv[3] ; *p != 0; p++) {
  1415.         if (*p == 'r') {
  1416.         flags |= TCL_TRACE_READS;
  1417.         } else if (*p == 'w') {
  1418.         flags |= TCL_TRACE_WRITES;
  1419.         } else if (*p == 'u') {
  1420.         flags |= TCL_TRACE_UNSETS;
  1421.         } else {
  1422.         goto badOps;
  1423.         }
  1424.     }
  1425.     if (flags == 0) {
  1426.         goto badOps;
  1427.     }
  1428.  
  1429.     length = strlen(argv[4]);
  1430.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1431.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1432.     tvarPtr->flags = flags;
  1433.     tvarPtr->errMsg = NULL;
  1434.     tvarPtr->length = length;
  1435.     flags |= TCL_TRACE_UNSETS;
  1436.     strcpy(tvarPtr->command, argv[4]);
  1437.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1438.         (ClientData) tvarPtr) != TCL_OK) {
  1439.         ckfree((char *) tvarPtr);
  1440.         return TCL_ERROR;
  1441.     }
  1442.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1443.         && (length >= 2)) == 0) {
  1444.     char *p;
  1445.     int flags, length;
  1446.     TraceVarInfo *tvarPtr;
  1447.     ClientData clientData;
  1448.  
  1449.     if (argc != 5) {
  1450.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1451.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1452.         return TCL_ERROR;
  1453.     }
  1454.  
  1455.     flags = 0;
  1456.     for (p = argv[3] ; *p != 0; p++) {
  1457.         if (*p == 'r') {
  1458.         flags |= TCL_TRACE_READS;
  1459.         } else if (*p == 'w') {
  1460.         flags |= TCL_TRACE_WRITES;
  1461.         } else if (*p == 'u') {
  1462.         flags |= TCL_TRACE_UNSETS;
  1463.         } else {
  1464.         goto badOps;
  1465.         }
  1466.     }
  1467.     if (flags == 0) {
  1468.         goto badOps;
  1469.     }
  1470.  
  1471.     /*
  1472.      * Search through all of our traces on this variable to
  1473.      * see if there's one with the given command.  If so, then
  1474.      * delete the first one that matches.
  1475.      */
  1476.  
  1477.     length = strlen(argv[4]);
  1478.     clientData = 0;
  1479.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1480.         TraceVarProc, clientData)) != 0) {
  1481.         tvarPtr = (TraceVarInfo *) clientData;
  1482.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1483.             && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1484.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1485.             TraceVarProc, clientData);
  1486.         if (tvarPtr->errMsg != NULL) {
  1487.             ckfree(tvarPtr->errMsg);
  1488.         }
  1489.         ckfree((char *) tvarPtr);
  1490.         break;
  1491.         }
  1492.     }
  1493.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1494.         && (length >= 2)) {
  1495.     ClientData clientData;
  1496.     char ops[4], *p;
  1497.     char *prefix = "{";
  1498.  
  1499.     if (argc != 3) {
  1500.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1501.             argv[0], " vinfo name\"", (char *) NULL);
  1502.         return TCL_ERROR;
  1503.     }
  1504.     clientData = 0;
  1505.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1506.         TraceVarProc, clientData)) != 0) {
  1507.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1508.         p = ops;
  1509.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1510.         *p = 'r';
  1511.         p++;
  1512.         }
  1513.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1514.         *p = 'w';
  1515.         p++;
  1516.         }
  1517.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1518.         *p = 'u';
  1519.         p++;
  1520.         }
  1521.         *p = '\0';
  1522.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1523.         Tcl_AppendElement(interp, ops);
  1524.         Tcl_AppendElement(interp, tvarPtr->command);
  1525.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1526.         prefix = " {";
  1527.     }
  1528.     } else {
  1529.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1530.         "\": should be variable, vdelete, or vinfo",
  1531.         (char *) NULL);
  1532.     return TCL_ERROR;
  1533.     }
  1534.     return TCL_OK;
  1535.  
  1536.     badOps:
  1537.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1538.         "\": should be one or more of rwu", (char *) NULL);
  1539.     return TCL_ERROR;
  1540. }
  1541.  
  1542. /*
  1543.  *----------------------------------------------------------------------
  1544.  *
  1545.  * TraceVarProc --
  1546.  *
  1547.  *    This procedure is called to handle variable accesses that have
  1548.  *    been traced using the "trace" command.
  1549.  *
  1550.  * Results:
  1551.  *    Normally returns NULL.  If the trace command returns an error,
  1552.  *    then this procedure returns an error string.
  1553.  *
  1554.  * Side effects:
  1555.  *    Depends on the command associated with the trace.
  1556.  *
  1557.  *----------------------------------------------------------------------
  1558.  */
  1559.  
  1560.     /* ARGSUSED */
  1561. static char *
  1562. TraceVarProc(clientData, interp, name1, name2, flags)
  1563.     ClientData clientData;    /* Information about the variable trace. */
  1564.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1565.     char *name1;        /* Name of variable or array. */
  1566.     char *name2;        /* Name of element within array;  NULL means
  1567.                  * scalar variable is being referenced. */
  1568.     int flags;            /* OR-ed bits giving operation and other
  1569.                  * information. */
  1570. {
  1571.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1572.     char *result;
  1573.     int code;
  1574.     Interp dummy;
  1575.     Tcl_DString cmd;
  1576.  
  1577.     result = NULL;
  1578.     if (tvarPtr->errMsg != NULL) {
  1579.     ckfree(tvarPtr->errMsg);
  1580.     tvarPtr->errMsg = NULL;
  1581.     }
  1582.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1583.  
  1584.     /*
  1585.      * Generate a command to execute by appending list elements
  1586.      * for the two variable names and the operation.  The five
  1587.      * extra characters are for three space, the opcode character,
  1588.      * and the terminating null.
  1589.      */
  1590.  
  1591.     if (name2 == NULL) {
  1592.         name2 = "";
  1593.     }
  1594.     Tcl_DStringInit(&cmd);
  1595.     Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
  1596.     Tcl_DStringAppendElement(&cmd, name1);
  1597.     Tcl_DStringAppendElement(&cmd, name2);
  1598.     if (flags & TCL_TRACE_READS) {
  1599.         Tcl_DStringAppend(&cmd, " r", 2);
  1600.     } else if (flags & TCL_TRACE_WRITES) {
  1601.         Tcl_DStringAppend(&cmd, " w", 2);
  1602.     } else if (flags & TCL_TRACE_UNSETS) {
  1603.         Tcl_DStringAppend(&cmd, " u", 2);
  1604.     }
  1605.  
  1606.     /*
  1607.      * Execute the command.  Be careful to save and restore the
  1608.      * result from the interpreter used for the command.
  1609.      */
  1610.  
  1611.     if (interp->freeProc == 0) {
  1612.         dummy.freeProc = (Tcl_FreeProc *) 0;
  1613.         dummy.result = "";
  1614.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1615.     } else {
  1616.         dummy.freeProc = interp->freeProc;
  1617.         dummy.result = interp->result;
  1618.         interp->freeProc = (Tcl_FreeProc *) 0;
  1619.     }
  1620.     code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
  1621.     Tcl_DStringFree(&cmd);
  1622.     if (code != TCL_OK) {
  1623.         tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1));
  1624.         strcpy(tvarPtr->errMsg, interp->result);
  1625.         result = tvarPtr->errMsg;
  1626.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1627.     }
  1628.     Tcl_SetResult(interp, dummy.result,
  1629.         (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
  1630.     }
  1631.     if (flags & TCL_TRACE_DESTROYED) {
  1632.     result = NULL;
  1633.     if (tvarPtr->errMsg != NULL) {
  1634.         ckfree(tvarPtr->errMsg);
  1635.     }
  1636.     ckfree((char *) tvarPtr);
  1637.     }
  1638.     return result;
  1639. }
  1640.  
  1641. /*
  1642.  *----------------------------------------------------------------------
  1643.  *
  1644.  * Tcl_WhileCmd --
  1645.  *
  1646.  *    This procedure is invoked to process the "while" Tcl command.
  1647.  *    See the user documentation for details on what it does.
  1648.  *
  1649.  * Results:
  1650.  *    A standard Tcl result.
  1651.  *
  1652.  * Side effects:
  1653.  *    See the user documentation.
  1654.  *
  1655.  *----------------------------------------------------------------------
  1656.  */
  1657.  
  1658.     /* ARGSUSED */
  1659. int
  1660. Tcl_WhileCmd(dummy, interp, argc, argv)
  1661.     ClientData dummy;            /* Not used. */
  1662.     Tcl_Interp *interp;            /* Current interpreter. */
  1663.     int argc;                /* Number of arguments. */
  1664.     char **argv;            /* Argument strings. */
  1665. {
  1666.     int result, value;
  1667.  
  1668.     if (argc != 3) {
  1669.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1670.         argv[0], " test command\"", (char *) NULL);
  1671.     return TCL_ERROR;
  1672.     }
  1673.  
  1674.     while (1) {
  1675.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1676.     if (result != TCL_OK) {
  1677.         return result;
  1678.     }
  1679.     if (!value) {
  1680.         break;
  1681.     }
  1682.     result = Tcl_Eval(interp, argv[2]);
  1683.     if (result == TCL_CONTINUE) {
  1684.         result = TCL_OK;
  1685.     } else if (result != TCL_OK) {
  1686.         if (result == TCL_ERROR) {
  1687.         char msg[60];
  1688.         sprintf(msg, "\n    (\"while\" body line %d)",
  1689.             interp->errorLine);
  1690.         Tcl_AddErrorInfo(interp, msg);
  1691.         }
  1692.         break;
  1693.     }
  1694.     }
  1695.     if (result == TCL_BREAK) {
  1696.     result = TCL_OK;
  1697.     }
  1698.     if (result == TCL_OK) {
  1699.     Tcl_ResetResult(interp);
  1700.     }
  1701.     return result;
  1702. }
  1703.